home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Graphics Programming (2nd Edition) / Visual Basic Graphics Programming 2nd Edition.iso / Src / Ch8 / Bounce1.frm (.txt) next >
Visual Basic Form  |  1999-05-28  |  8KB  |  230 lines
  1. VERSION 5.00
  2. Begin VB.Form frmBounce1 
  3.    Caption         =   "Bounce1"
  4.    ClientHeight    =   5235
  5.    ClientLeft      =   1320
  6.    ClientTop       =   825
  7.    ClientWidth     =   6870
  8.    LinkTopic       =   "Form1"
  9.    PaletteMode     =   1  'UseZOrder
  10.    ScaleHeight     =   349
  11.    ScaleMode       =   3  'Pixel
  12.    ScaleWidth      =   458
  13.    Begin VB.TextBox txtFramesPerSecond 
  14.       Height          =   285
  15.       Left            =   1440
  16.       TabIndex        =   4
  17.       Text            =   "20"
  18.       Top             =   4920
  19.       Width           =   375
  20.    End
  21.    Begin VB.TextBox txtNumBalls 
  22.       Height          =   285
  23.       Left            =   1440
  24.       TabIndex        =   3
  25.       Text            =   "20"
  26.       Top             =   4560
  27.       Width           =   375
  28.    End
  29.    Begin VB.CommandButton cmdStart 
  30.       Caption         =   "Start"
  31.       Default         =   -1  'True
  32.       Height          =   495
  33.       Left            =   2160
  34.       TabIndex        =   1
  35.       Top             =   4620
  36.       Width           =   855
  37.    End
  38.    Begin VB.PictureBox picCourt 
  39.       AutoRedraw      =   -1  'True
  40.       Height          =   4455
  41.       Left            =   0
  42.       ScaleHeight     =   293
  43.       ScaleMode       =   3  'Pixel
  44.       ScaleWidth      =   453
  45.       TabIndex        =   0
  46.       Top             =   0
  47.       Width           =   6855
  48.    End
  49.    Begin VB.Label Label1 
  50.       Caption         =   "Frames per second:"
  51.       Height          =   255
  52.       Index           =   0
  53.       Left            =   0
  54.       TabIndex        =   5
  55.       Top             =   4920
  56.       Width           =   1455
  57.    End
  58.    Begin VB.Label Label1 
  59.       Caption         =   "Number of balls:"
  60.       Height          =   255
  61.       Index           =   1
  62.       Left            =   0
  63.       TabIndex        =   2
  64.       Top             =   4560
  65.       Width           =   1455
  66.    End
  67. Attribute VB_Name = "frmBounce1"
  68. Attribute VB_GlobalNameSpace = False
  69. Attribute VB_Creatable = False
  70. Attribute VB_PredeclaredId = True
  71. Attribute VB_Exposed = False
  72. Option Explicit
  73. Private xmax As Integer
  74. Private ymax As Integer
  75. Private NumBalls As Integer
  76. Private BallX() As Integer
  77. Private BallY() As Integer
  78. Private BallDx() As Integer
  79. Private BallDy() As Integer
  80. Private BallRadius() As Integer
  81. Private BallColor() As Long
  82. Private Playing As Boolean
  83. Private NumPlayed As Long
  84. ' Draw some random rectangles on the bacground.
  85. Private Sub DrawBackground()
  86. Dim i As Integer
  87. Dim wid As Single
  88. Dim hgt As Single
  89.     ' Start with a clean slate.
  90.     picCourt.Line (0, 0)-(picCourt.ScaleWidth, picCourt.ScaleHeight), picCourt.BackColor, BF
  91.     ' Draw some rectangles.
  92.     For i = 1 To 10
  93.         hgt = 10 + Rnd * xmax / 3
  94.         wid = 10 + Rnd * ymax / 3
  95.         picCourt.Line (Int(Rnd * xmax), Int(Rnd * ymax))-Step(hgt, wid), QBColor(Int(Rnd * 16)), BF
  96.     Next i
  97.     ' Make the rectangles part of the permanent background.
  98.     picCourt.Picture = picCourt.Image
  99. End Sub
  100. ' Generate some random data.
  101. Private Sub InitData()
  102. Dim ball As Integer
  103. Dim R As Integer
  104. Dim clr As Integer
  105.     ' See how many balls there should be.
  106.     If Not IsNumeric(txtNumBalls.Text) Then _
  107.         txtNumBalls.Text = "10"
  108.     NumBalls = CInt(txtNumBalls.Text)
  109.     ReDim BallRadius(1 To NumBalls)
  110.     ReDim BallX(1 To NumBalls)
  111.     ReDim BallY(1 To NumBalls)
  112.     ReDim BallDx(1 To NumBalls)
  113.     ReDim BallDy(1 To NumBalls)
  114.     ReDim BallColor(1 To NumBalls)
  115.     ' Set the initial ball data.
  116.     For ball = 1 To NumBalls
  117.         R = Int(10 * Rnd + 5)
  118.         BallRadius(ball) = R
  119.         BallX(ball) = Int((xmax - R + 1) * Rnd)
  120.         BallY(ball) = Int((ymax - R + 1) * Rnd)
  121.         BallDx(ball) = Int(21 * Rnd - 10)
  122.         BallDy(ball) = Int(21 * Rnd - 10)
  123.         clr = Int(15 * Rnd)
  124.         If clr >= 7 Then clr = clr + 1
  125.         BallColor(ball) = QBColor(clr)
  126.     Next ball
  127. End Sub
  128. ' Start the animation.
  129. Private Sub cmdStart_Click()
  130.     If Playing Then
  131.         Playing = False
  132.         cmdStart.Caption = "Stopped"
  133.         cmdStart.Enabled = False
  134.     Else
  135.         cmdStart.Caption = "Stop"
  136.         Playing = True
  137.         InitData
  138.         PlayData
  139.         Playing = False
  140.         cmdStart.Caption = "Start"
  141.         cmdStart.Enabled = True
  142.     End If
  143. End Sub
  144. ' Play the animation.
  145. Private Sub PlayData()
  146. Dim ms_per_frame As Long
  147. Dim start_time As Single
  148. Dim stop_time As Single
  149.     ' Draw a random background.
  150.     DrawBackground
  151.     ' See how fast we should go.
  152.     If Not IsNumeric(txtFramesPerSecond.Text) Then _
  153.         txtFramesPerSecond.Text = "10"
  154.     ms_per_frame = 1000 \ CLng(txtFramesPerSecond.Text)
  155.     ' Start the animation.
  156.     NumPlayed = 0
  157.     start_time = Timer
  158.     PlayImages ms_per_frame
  159.     ' Display results.
  160.     stop_time = Timer
  161.     MsgBox "Displayed" & Str$(NumPlayed) & _
  162.         " frames in " & _
  163.         Format$(stop_time - start_time, "0.00") & _
  164.         " seconds (" & _
  165.         Format$(NumPlayed / (stop_time - start_time), "0.00") & _
  166.         " FPS)."
  167. End Sub
  168. ' Play the animation.
  169. Private Sub PlayImages(ByVal ms_per_frame As Long)
  170. Dim ball As Integer
  171. Dim next_time As Long
  172.     ' Get the current time.
  173.     next_time = GetTickCount()
  174.     ' Start the animation.
  175.     Do While Playing
  176.         NumPlayed = NumPlayed + 1
  177.         ' Restore the background.
  178.         picCourt.Cls
  179.         ' Draw the balls.
  180.         For ball = 1 To NumBalls
  181.             picCourt.FillColor = BallColor(ball)
  182.             picCourt.Circle _
  183.                 (BallX(ball), BallY(ball)), _
  184.                 BallRadius(ball), BallColor(ball)
  185.         Next ball
  186.         ' Move the balls for the next frame,
  187.         ' keeping them within picCourt.
  188.         For ball = 1 To NumBalls
  189.             BallX(ball) = BallX(ball) + BallDx(ball)
  190.             If BallX(ball) < BallRadius(ball) Then
  191.                 BallX(ball) = 2 * BallRadius(ball) - BallX(ball)
  192.                 BallDx(ball) = -BallDx(ball)
  193.             ElseIf BallX(ball) > xmax - BallRadius(ball) Then
  194.                 BallX(ball) = 2 * (xmax - BallRadius(ball)) - BallX(ball)
  195.                 BallDx(ball) = -BallDx(ball)
  196.             End If
  197.             BallY(ball) = BallY(ball) + BallDy(ball)
  198.             If BallY(ball) < BallRadius(ball) Then
  199.                 BallY(ball) = 2 * BallRadius(ball) - BallY(ball)
  200.                 BallDy(ball) = -BallDy(ball)
  201.             ElseIf BallY(ball) > ymax - BallRadius(ball) Then
  202.                 BallY(ball) = 2 * (ymax - BallRadius(ball)) - BallY(ball)
  203.                 BallDy(ball) = -BallDy(ball)
  204.             End If
  205.         Next ball
  206.         ' Wait until it's time for the next frame.
  207.         next_time = next_time + ms_per_frame
  208.         WaitTill next_time
  209.         If Not Playing Then Exit Do
  210.     Loop
  211. End Sub
  212. Private Sub Form_Load()
  213.     Randomize
  214.     ' Set FillStyle to vbSolid.
  215.     picCourt.FillStyle = vbSolid
  216. End Sub
  217. ' Make the ball court nice and big.
  218. Private Sub Form_Resize()
  219. Const GAP = 3
  220.     txtFramesPerSecond.Top = ScaleHeight - GAP - txtFramesPerSecond.Height
  221.     Label1(0).Top = txtFramesPerSecond.Top
  222.     txtNumBalls.Top = txtFramesPerSecond.Top - GAP - txtNumBalls.Height
  223.     Label1(1).Top = txtNumBalls.Top
  224.     cmdStart.Top = (txtNumBalls.Top + txtFramesPerSecond.Top + txtFramesPerSecond.Height - cmdStart.Height) / 2
  225.     picCourt.Move 0, 0, ScaleWidth, txtNumBalls.Top - GAP
  226.     xmax = picCourt.ScaleWidth - 1
  227.     ymax = picCourt.ScaleHeight - 1
  228.     picCourt.Picture = picCourt.Image
  229. End Sub
  230.